unit uDZBinarySerializer;

interface

uses
  SysUtils, Classes, uDZSysUtils, uDZHash, uDZStr, uDZSerializer, uDZHashTable;

{$INCLUDE 'DZCompiler.inc'}

{$WARNINGS OFF}
{$HINTS OFF}

type
  TDataTypeRange = Byte;
  THeaderSizeRange = Byte;
  TPropCountRange = Byte;

  TDataTypes = set of TDataType; 

  TNoName = packed record
    case TDataType of
      dtRootObject: (Option: Word);
      dtClass: (HdrSize: THeaderSizeRange; Reserved: Byte)
  end;
  
  TObjectHeader = packed record
    Kind: TDataTypeRange;
    PropCount: TPropCountRange;
    Union: TNoName;
    Size: Integer;
  end;
  PObjectHeader = ^TObjectHeader;

  TListHeader = packed record
    Kind: TDataTypeRange;
    ItemType: TDataTypeRange;  
    ItemCount: Integer;
    Size: Integer;    
  end;
  PListHeader = ^TListHeader;
  
  PNestedObjectNode  = ^TNestedObjectNode;
  TNestedObjectNode = record
    Kind: TDataType;
    ListKind: TDataType;
    HeaderSize: Integer;
    Size: Integer;
    Offset: Int64;
    Previous: PNestedObjectNode;
    case Integer of
      0: (PropCount: Integer);
      1: (ItemCount: Integer);
  end;
  
  TDzBinaryClassReader = class(TDzClassReader)
  private
    CurObject: PNestedObjectNode;
    NameEncoding: TTextEncoding;
    NameStore: TDzNameStore;
  private
    procedure ClearNested;
    function ReadStrLen(Level: Integer): Integer;
  protected
    procedure ReadObjectHeader;
    procedure ReadListHeader;
    procedure SkipPropName;
    procedure SkipProp(Kind: TDataType; SkipName: Boolean = True);
    function FindPropUntil(Kinds: TDataTypes; const Name: TNameString;
      EndPos: Int64): TDataType;
    function FindProperty(Kinds: TDataTypes; const Name: TNameString): TDataType;
    function HashPropName(const Name: TNameString): Word;
    function SamePropName(const Name: TNameString): Boolean;
    function ReadAnsiName(out Name: TNameString; Len: Integer): Integer;
    function ReadUTF8Name(out Name: TNameString; Len: Integer): Integer;
    function ReadUTF16Name(out Name: TNameString; Len: Integer): Integer;
    function ReadName(out Name: TNameString): Integer;
    function ReadPropType: TDataType;
    function _ReadByte: Byte;
    function _ReadWord: Word;
    function _ReadInt32: Integer;
    function _ReadQWord: Integer;
    function _ReadAnsiStr(out Str: AnsiString; LenLevel: Integer): Integer;
    function _ReadUnicodeStr(out Str: WideString; LenLevel: Integer): Integer;
    function _ReadWideStr(out Str: WideString; LenLevel: Integer): Integer;
  public
    destructor Destroy; override;
    function BeginReadRootObject(out ClsName: TNameString): Boolean; override;
    function BeginReadObject(const Name: TNameString): Boolean; override;
    procedure EndReadObject; override;
    function BeginReadList(out Count: Integer): Boolean; override;
    procedure EndReadList; override;
    function BeginReadListItem(Index: Integer): Boolean; override;
    function EndReadListItem: Boolean; override;
    procedure ReadPropList(props: TStrings); override;
    function ReadAnsiChar(const Name: TNameString; out Value: AnsiChar): Boolean; override;
    function ReadWideChar(const Name: TNameString; out Value: WideChar): Boolean; override;
    function ReadDWord(const Name: TNameString; out Value: Integer): Boolean; override;
    function ReadQWord(const Name: TNameString; out Value: Int64): Boolean; override;
    function ReadFloat(const Name: TNameString; out Value: Extended): Boolean; override;

    function ReadAnsiStr(const Name: TNameString;
      out Value: AnsiString): Boolean; override;

    function ReadWideStr(const Name: TNameString;
      out Value: WideString): Boolean; override;

    function ReadUnicodeStr(const Name: TNameString;
      out Value: WideString): Boolean; override;

    function ReadAnsiStrListItem(Index: Integer; out Value: AnsiString;
      out More: Boolean): Boolean; override;

    function ReadWStrListItem(Index: Integer; out Value: WideString;
      out More: Boolean): Boolean; override;

    function ReadUStrListItem(Index: Integer; out Value: WideString;
      out More: Boolean): Boolean; override;

    function ReadPointer(const Name: TNameString; Buf: Pointer;
      var Len: Integer): Boolean; override;
  end;

  TDzBinaryClassWriter = class(TDzClassWriter)
  private
    fAnsiNameTable: TDzAnsiStrHashTable;
    fWideNameTable: TDzWideStrHashTable;
    CurObject: PNestedObjectNode;
    procedure ClearNested;
  protected
    procedure StreamChanged; override;
    procedure _WriteWord(const Name: TNameString; Value: Word); override;
    procedure _WriteWideChar(const Name: TNameString; Value: WideChar); override;
    procedure _WriteDWord(const Name: TNameString; Value: Integer); override;
    procedure _WriteQWord(const Name: TNameString; Value: Int64); override;
    function FindName(const Name: TNameString): Int64;
    procedure SetNamePostion(const Name: TNameString; Position: Int64);
    procedure WriteObjectHeader(Kind: TDataType; const Name: TNameString);
    procedure UpdateObjectHeader;
    procedure WritePropKind(_type: TDataType);
    function _WriteAnsiStr(const Name: TNameString; Str: PAnsiChar; Len: Integer): Integer;
    function _WriteWideStr(const Name: TNameString; Str: PWideChar; Len: Integer): Integer;
    function WriteAnsiName(const Name: TNameString): Integer;
    function WriteUTF16Name(const Name: TNameString): Integer;
    function WriteUtf8Name(const Name: TNameString): Integer;
    function WriteName(const Name: TNameString): Integer;
  public
    destructor Destroy; override;
    procedure BeginWriteRootObject(const ClsName: string); override;
    procedure EndWriteRootObject(const Name: TNameString); override;
    function BeginWriteObject(const Name: TNameString): Boolean; override;
    procedure EndWriteObject(const Name: TNameString); override;
    function BeginWriteList(ListKind: TDataType; ItemCount: Integer): Boolean; override;
    procedure EndWriteList; override;
    function BeginWriteListItem(Index: Integer): Boolean; override;
    procedure EndWriteListItem; override;
    procedure WriteAnsiChar(const Name: TNameString; Value: AnsiChar); override;
    procedure WriteByte(const Name: TNameString; Value: Byte); override;
    procedure WriteFloat(const Name: TNameString; Value: Extended); override;
    procedure WriteAnsiStr(const Name: TNameString; const Value: AnsiString); override;
    procedure WriteWideStr(const Name: TNameString; const Value: WideString); override;
    procedure WriteUTF16Str(const Name: TNameString; const Value: WideString); override;
    procedure WriteAnsiStrListItem(Index: Integer; const Value: AnsiString); override;
    procedure WriteWStrListItem(Index: Integer; const Value: WideString); override;
    procedure WriteUStrListItem(Index: Integer; const Value: WideString); override;
    procedure WritePointer(const Name: TNameString; Buf: Pointer; Len: Integer); override;

    property AnsiNameTable: TDzAnsiStrHashTable read fAnsiNameTable write fAnsiNameTable;
    property WideNameTable: TDzWideStrHashTable read fWideNameTable write fWideNameTable;
  end;

implementation

const
  STRING_FLAG_PTR = $80000000;
  LEN_BYTES: array [0..2] of Integer = (1, 2, 4);

{ TDzBinaryClassWriter }

function TDzBinaryClassWriter.BeginWriteList(ListKind: TDataType;
  ItemCount: Integer): Boolean;
var
  Node: PNestedObjectNode;
begin
  New(Node);
  Node.Previous := CurObject;
  CurObject := Node;
  Node.Kind := dtList;
  Node.ListKind := ListKind;
  Node.Offset := Stream.Position;
  Node.PropCount := 0;
  Stream.Seek(SizeOf(TListHeader), soFromCurrent);
  Result := True;
end;

function TDzBinaryClassWriter.BeginWriteListItem(Index: Integer): Boolean;
begin
  BeginWriteObject('');
end;

function TDzBinaryClassWriter.BeginWriteObject(const Name: TNameString): Boolean;
begin
  WriteObjectHeader(dtClass, Name);
  Result := True;
end;

procedure TDzBinaryClassWriter.ClearNested;
var
  Node: PNestedObjectNode;
begin
  while CurObject <> nil do
  begin
    Node := CurObject;
    CurObject := Node.Previous;
    Dispose(Node);
  end;
end;

destructor TDzBinaryClassWriter.Destroy;
begin
  ClearNested;
  fAnsiNameTable.Free;
  fWideNameTable.Free;
  inherited;
end;

procedure TDzBinaryClassWriter.EndWriteList;
var
  Node: PNestedObjectNode;
  Bookmark: Int64;
  Header: TListHeader;
begin
  Bookmark := Stream.Position;
  Header.Kind := Ord(dtList);
  Header.ItemType := Ord(CurObject^.ListKind);
  Header.ItemCount := CurObject^.PropCount;
  Header.Size := Bookmark - CurObject.Offset;
  Stream.Position := CurObject.Offset;
  Stream.Write(Header, SizeOf(Header));
  Stream.Position := Bookmark;
  
  Node := CurObject;
  CurObject := Node.Previous;
  if Assigned(CurObject) then Inc(CurObject^.PropCount);
  Dispose(Node);
end;

procedure TDzBinaryClassWriter.EndWriteObject;
var
  Node: PNestedObjectNode;
begin
  UpdateObjectHeader;
  Node := CurObject;
  CurObject := Node.Previous;
  if Assigned(CurObject) then Inc(CurObject^.PropCount);
  Dispose(Node);
end;

procedure TDzBinaryClassWriter.EndWriteListItem;
begin
  EndWriteObject('');
end;

procedure TDzBinaryClassWriter.EndWriteRootObject(const Name: TNameString);
begin
  EndWriteObject(Name);
end;

function TDzBinaryClassWriter.FindName(const Name: TNameString): Int64;
var
  Value: Pointer;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    if (NameStore <> nsPointer) or (fAnsiNameTable = nil) then Result := -1
    else if (fAnsiNameTable.Find2(@Name[1], Length(Name),
      @Value)) then Result := Integer(Value)
    else Result := -1;
  end
  else begin
    if (NameStore <> nsPointer) or (fWideNameTable = nil) then Result := -1
    else if (fWideNameTable.Find2(@Name[1], Length(Name),
      @Value)) then Result := Integer(Value)
    else Result := -1;
  end;
end;

procedure TDzBinaryClassWriter.SetNamePostion(const Name: TNameString; Position: Int64);
begin
  if NameStore <> nsPointer then Exit;
  if SizeOf(Name[1]) = 1 then
  begin
    if fAnsiNameTable = nil then
      fAnsiNameTable := TDzAnsiStrHashTable.Create(CalcHashTableSize(100));
    fAnsiNameTable[Name] := Pointer(Position);
  end
  else begin
    if fWideNameTable = nil then
      fWideNameTable := TDzWideStrHashTable.Create(CalcHashTableSize(100));
    fWideNameTable[Name] := Pointer(Position);
  end;
end;

procedure TDzBinaryClassWriter.StreamChanged;
begin
  inherited;
  if Assigned(fAnsiNameTable) then fAnsiNameTable.Clear;
  if Assigned(fWideNameTable) then fWideNameTable.Clear;
end;

procedure TDzBinaryClassWriter.WriteByte(const Name: TNameString; Value: Byte);
begin
  WritePropKind(dtByte);
  WriteName(Name);
  Stream.Write(Value, SizeOf(Value));
end;

{$HINTS OFF}
procedure TDzBinaryClassWriter.WriteAnsiChar(const Name: TNameString; Value: AnsiChar);
begin
  WriteByte(Name, Byte(Value));
end;

function TDzBinaryClassWriter.WriteAnsiName(const Name: TNameString): Integer;
var
  Len: Byte;
  hash: Word;
  astr: array [0..255] of AnsiChar;
  pastr: PAnsiChar;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    pastr := @Name[1];
    Len := Length(Name);
  end
  else begin
    pastr := @astr[0];
    Len := wctomb(@Name[1], Length(Name), astr, SizeOf(astr));
  end;
  if NameStore = nsHash then
  begin
    //write name hash value
    hash := ELFHash(pastr, Len, ccUpper) mod $ffff;
    Stream.Write(hash, SizeOf(hash));
    Result := SizeOf(hash);
  end
  else begin
    Stream.Write(Len, SizeOf(Len));
    Stream.Write(pastr^, Len);
    Result := SizeOf(Len) + Len;
  end;
end;
{$HINTS ON}

procedure TDzBinaryClassWriter.WriteAnsiStrListItem(
  Index: Integer; const Value: AnsiString);
begin
  _WriteAnsiStr('', PAnsiChar(Value), Length(Value));   
end;

procedure TDzBinaryClassWriter.WriteAnsiStr(const Name: TNameString;
  const Value: AnsiString);
begin
  _WriteAnsiStr(Name, PAnsiChar(Value), Length(Value));
end;

procedure TDzBinaryClassWriter.UpdateObjectHeader;
var
  Bookmark: Int64;
  Header: TObjectHeader;
begin
  Bookmark := Stream.Position;
  Header.Kind := Ord(CurObject^.Kind);

  if Header.Kind = Ord(dtRootObject) then
  begin
    Header.Union.Option := Ord(NameEncoding);
    Header.Union.Option := Header.Union.Option or (Byte(NameStore) shl 2);
  end
  else begin
    Header.Union.Reserved := 0;
    Header.Union.HdrSize := CurObject^.HeaderSize;
  end;

  Header.PropCount := CurObject^.PropCount;
  Header.Size := Bookmark - CurObject.Offset;
  Stream.Position := CurObject.Offset;
  Stream.Write(Header, SizeOf(Header));
  Stream.Position := Bookmark;
end;

procedure TDzBinaryClassWriter.WriteFloat(const Name: TNameString; Value: Extended);
begin
  WritePropKind(dtFloat);
  WriteName(Name);
  Stream.Write(Value, SizeOf(Value));
end;

procedure TDzBinaryClassWriter._WriteQWord(const Name: TNameString; Value: Int64);
begin
  WritePropKind(dtInt64);
  WriteName(Name);
  Stream.Write(Value, SizeOf(Value));
end;

procedure TDzBinaryClassWriter._WriteDWord(const Name: TNameString; Value: Integer);
begin
  WritePropKind(dtInt32);
  WriteName(Name);
  Stream.Write(Value, SizeOf(Value));
end;

function TDzBinaryClassWriter.WriteName(const Name: TNameString): Integer;
var
  NamePos: Int64;
  StrTag: Cardinal;
begin
  if NameStore <> nsHash then
  begin
    NamePos := FindName(Name);
    if NamePos <> -1 then
    begin
      StrTag := (Stream.Position + SizeOf(StrTag) - NamePos) or STRING_FLAG_PTR;
      StrTag := SysToBigEndian(StrTag);
      Stream.Write(StrTag, SizeOf(StrTag));
      Result := SizeOf(StrTag);
      Exit;
    end;
    SetNamePostion(Name, Stream.Position);
  end;
  case NameEncoding of
    teAnsi: Result := WriteAnsiName(Name);
    teUTF8: Result := WriteUtf8Name(Name);
    teUTF16: Result := WriteUTF16Name(Name);
    else begin
      NotSupported;
      Result := 0;
    end;
  end;
end;

procedure TDzBinaryClassWriter.WriteObjectHeader(Kind: TDataType;
  const Name: TNameString);
var
  Node: PNestedObjectNode;
begin
  New(Node);
  Node.Previous := CurObject;
  CurObject := Node;
  Node.Kind := Kind;
  Node.Offset := Stream.Position;
  Node.PropCount := 0;
  Node.HeaderSize := SizeOf(TObjectHeader);
  Stream.Seek(SizeOf(TObjectHeader), soFromCurrent);
  if Length(Name) > 0 then Inc(Node.HeaderSize, WriteName(Name));
end;

procedure TDzBinaryClassWriter.WritePointer(const Name: TNameString;
  Buf: Pointer; Len: Integer);
begin
  {inherited;}  //don't call base class implemention
  WritePropKind(dtPointer);
  WriteName(Name);
  Stream.Write(Len, SizeOf(Len));
  Stream.WriteBuffer(Buf^, Len);
end;

procedure TDzBinaryClassWriter.WritePropKind(_type: TDataType);
var
  Value: TDataTypeRange;
begin
  Value := Ord(_type);
  Stream.Write(Value, SizeOf(Value));
  Inc(CurObject^.PropCount);
end;

procedure TDzBinaryClassWriter.BeginWriteRootObject(const ClsName: string);
begin
  AcquireStream;
  ClearNested;
  WriteObjectHeader(dtRootObject, '');
end;

function TDzBinaryClassWriter.WriteUTF16Name(const Name: TNameString): Integer;
var
  Len: Byte;
  hash: Word;
  wstr: array [0..255] of WideChar;
  pwstr: PWideChar;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    Len := mbtowc(@Name[1], Length(Name), wstr, Length(wstr));
    pwstr := @wstr[0];
  end
  else begin
    pwstr := @Name[1];
    Len := Length(Name);
  end;
  if NameStore = nsHash then
  begin
    hash := ELFHash(PAnsiChar(pwstr), Len * 2, ccUpper) mod $ffff;
    Stream.Write(hash, SizeOf(hash));
    Result := SizeOf(Integer);
  end
  else begin
    Stream.Write(Len, SizeOf(Len));
    Stream.Write(pwstr^, Len * 2);
    Result := SizeOf(Len) + Len * 2;
  end;
end;

procedure TDzBinaryClassWriter.WriteUStrListItem(
  Index: Integer; const Value: WideString);
begin
  _WriteWideStr('', PWideChar(Value), Length(Value));  
end;

procedure TDzBinaryClassWriter.WriteUTF16Str(
  const Name: TNameString; const Value: WideString);
begin
  _WriteWideStr(Name, PWideChar(Value), Length(Value));
end;

function TDzBinaryClassWriter.WriteUtf8Name(const Name: TNameString): Integer;
var
  Len: Byte;
  hash: Word;
  wstr: array [0..255] of WideChar;
  astr: array [0..255] of AnsiChar;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    Len := mbtowc(@Name[1], Length(Name), wstr, Length(wstr));
    Len := UnicodeToUtf8(wstr, Len, astr, SizeOf(astr));
  end
  else begin
    Len := UnicodeToUtf8(@Name[1], Length(Name), astr, SizeOf(astr));
  end;
  if NameStore = nsHash then
  begin
    hash := ELFHash(PAnsiChar(@astr[1]), Length(Name), ccUpper) mod $ffff;
    Stream.Write(hash, SizeOf(hash));
    Result := SizeOf(Integer);
  end
  else begin
    Stream.Write(Len, SizeOf(Len));
    Stream.Write(astr, Len);
    Result := SizeOf(Len) + Len;
  end;
end;

procedure TDzBinaryClassWriter._WriteWideChar(const Name: TNameString; Value: WideChar);
begin
  WriteWord(Name, Word(Value));
end;

procedure TDzBinaryClassWriter.WriteWStrListItem(
  Index: Integer; const Value: WideString);
begin
  _WriteWideStr('', PWideChar(Value), Length(Value));
end;

procedure TDzBinaryClassWriter.WriteWideStr(const Name: TNameString;
  const Value: WideString);
begin
  _WriteWideStr(Name, PWideChar(Value), Length(Value));
end;

procedure TDzBinaryClassWriter._WriteWord(const Name: TNameString; Value: Word);
begin
  WritePropKind(dtWord);
  WriteName(Name);
  Stream.Write(Value, SizeOf(Value));
end;

function TDzBinaryClassWriter._WriteAnsiStr(const Name: TNameString;
  Str: PAnsiChar; Len: Integer): Integer;
begin
  if Len <= $ff then
  begin
    WritePropKind(dtShortAnsiStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Byte(Len), 1);
    Inc(Result, 1 + Len);
  end
  else if Len <= $ffff then
  begin
    WritePropKind(dtSmallAnsiStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Word(Len), 2);
    Inc(Result, 2 + Len);
  end
  else begin
    WritePropKind(dtLongAnsiStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Len, SizeOf(Len));
    Inc(Result, 4 + Len);
  end;
  Stream.Write(Str^, Len);
end;

function TDzBinaryClassWriter._WriteWideStr(const Name: TNameString;
  Str: PWideChar; Len: Integer): Integer;
begin
  if Len <= $ff then
  begin
    WritePropKind(dtShortWideStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Byte(Len), 1);
    Inc(Result, 1 + Len * 2);
  end
  else if Len <= $ffff then
  begin
    WritePropKind(dtSmallWideStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Word(Len), 2);
    Inc(Result, 2 + Len * 2);
  end
  else begin
    WritePropKind(dtLongWideStr);
    Result := 1;
    if Length(Name) > 0 then Inc(Result, WriteName(Name));
    Stream.Write(Len, SizeOf(Len));
    Inc(Result, 4 + Len * 2);
  end;
  Stream.Write(Str^, Len * 2);
end;

{ TDzBinaryClassReader }

function TDzBinaryClassReader.BeginReadList(out Count: Integer): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtList], '');
  Result := Kind <> dtUnknown;
  if Result then
    Count := CurObject^.ItemCount;
end;

function TDzBinaryClassReader.BeginReadListItem(Index: Integer): Boolean;
var
  EndPos: Int64;
begin
  EndPos := CurObject.Offset + CurObject.Size;
  if Stream.Position >= EndPos then Result := False
  else begin
    ReadObjectHeader;
    Result := True;
  end;
end;

function TDzBinaryClassReader.BeginReadObject(const Name: TNameString): Boolean;
begin
  Result := FindProperty([dtClass], Name) <> dtUnknown;
end;

function TDzBinaryClassReader.BeginReadRootObject(out ClsName: TNameString): Boolean;
var
  Header: TObjectHeader;
  BytesRead: Integer;
  Bookmark: Int64;
begin
  ClearNested;
  Bookmark := Stream.Position;
  BytesRead := Stream.Read(Header, SizeOf(Header));
  Stream.Position := Bookmark;
  NameEncoding := TTextEncoding(Header.Union.Option and 3);
  NameStore := TDzNameStore((Header.Union.Option shr 2) and 3);
  if (BytesRead < SizeOf(Header)) or (Header.Kind <> Word(dtRootObject)) then
  begin
    Result := False;
    Exit;
  end;
  Stream.Position := Bookmark;
  ReadObjectHeader;
  Result := True;
end;

procedure TDzBinaryClassReader.ClearNested;
var
  Node: PNestedObjectNode;
begin
  while CurObject <> nil do
  begin
    Node := CurObject;
    CurObject := Node.Previous;
    Dispose(Node);
  end;
end;

destructor TDzBinaryClassReader.Destroy;
begin
  ClearNested;
  inherited;
end;

procedure TDzBinaryClassReader.EndReadList;
begin
  EndReadObject;
end;

function TDzBinaryClassReader.EndReadListItem: Boolean;
begin
  EndReadObject;
  with CurObject^ do Result := (Offset + Size) > Stream.Position;
end;

procedure TDzBinaryClassReader.EndReadObject;
var
  Node: PNestedObjectNode;
begin
  Node := CurObject;
  Stream.Position := Node.Offset + Node.Size;
  CurObject := Node.Previous;
  Dispose(Node);
end;

function TDzBinaryClassReader.FindProperty(Kinds: TDataTypes;
  const Name: TNameString): TDataType;
var
  Bookmark: Int64;
begin
  Bookmark := Stream.Position;
  try
    with CurObject^ do
    begin
      Result := FindPropUntil(Kinds, Name, Offset + Size);
      if Result <> dtUnknown then Exit;
      if Bookmark = Offset + HeaderSize then Exit;

      //rewind reading pointer
      Stream.Position := Offset + HeaderSize;
      Result := FindPropUntil(Kinds, Name, Bookmark);
    end;
  finally
    // property not found or exception happend, restore read pointer
    if Result = dtUnknown then Stream.Position := Bookmark;
  end;
end;

function TDzBinaryClassReader.HashPropName(const Name: TNameString): Word;
begin
  case NameEncoding of
    teAnsi: Result := HashAnsiPropName(Name);
    teUTF8: Result := HashUTF8PropName(Name);
    teUTF16: Result := HashUTF16PropName(Name);
    else Result := 0;
  end;
end;

function TDzBinaryClassReader.SamePropName(const Name: TNameString): Boolean;
var
  Hash: Word;
  ThisName: TNameString;
begin
  if NameStore = nsHash then
  begin
    Stream.Read(Hash, SizeOf(Hash));
    Result := Hash = HashPropName(Name);
  end
  else begin
    ReadName(ThisName);
    Result := crEqual = AnsiCompare(@Name[1], Length(Name),
      @ThisName[1], Length(ThisName), [coIgnoreCase]);
  end;
end;

function TDzBinaryClassReader.ReadAnsiChar(
  const Name: TNameString; out Value: AnsiChar): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtByte], Name);
  Result := Kind <> dtUnknown;
  if Result then Stream.Read(Value, SizeOf(Value));
end;

{$HINTS OFF}
function TDzBinaryClassReader.ReadAnsiName(
  out Name: TNameString; Len: Integer): Integer;
var
  astr: array [0..255] of AnsiChar;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    SetLength(Name, Len);
    Stream.Read(Name[1], Len);
    Result := Len;
  end
  else begin
    Stream.Read(astr, Len);
    SetLength(Name, Len);
    SetLength(Name, uDZStr.mbtowc(astr, Len, PWideChar(Pointer(@Name[1])), Len));
    Result := Len;
  end;
end;
{$HINTS ON}

function TDzBinaryClassReader.ReadAnsiStrListItem(Index: Integer;
  out Value: AnsiString; out More: Boolean): Boolean;
var
  Kind: TDataType;
  wstr: WideString;
begin
  Result := False;
  if CurObject^.Offset + CurObject^.Size <= Stream.Position then Exit;
  Kind := ReadPropType;
  if Kind in [dtShortAnsiStr, dtSmallAnsiStr, dtLongAnsiStr] then
  begin
    _ReadAnsiStr(Value, Ord(Kind) - Ord(dtShortAnsiStr));
    with CurObject^ do More := (Offset + Size) > Stream.Position;
    Result := True;
  end
  else if Kind in [dtShortWideStr, dtSmallWideStr, dtLongWideStr] then
  begin
    _ReadWideStr(wstr, Ord(Kind) - Ord(dtShortWideStr));
    Value := AnsiString(wstr);
    with CurObject^ do
      More := (Offset + Size) > Stream.Position;
    Result := True;
  end;
end;

function TDzBinaryClassReader.ReadAnsiStr(const Name: TNameString;
  out Value: AnsiString): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtShortAnsiStr, dtSmallAnsiStr, dtLongAnsiStr], Name);
  Result := Kind <> dtUnknown;
  if Result then _ReadAnsiStr(Value, Ord(Kind) - Ord(dtShortAnsiStr));
end;

procedure TDzBinaryClassReader.ReadObjectHeader;
var
  Node: PNestedObjectNode;
  Header: TObjectHeader;
begin
  New(Node);
  Node.Offset := Stream.Position;
  Stream.Read(Header, SizeOf(Header));
  Node.Kind := TDataType(Header.Kind);
  if Node.Kind = dtRootObject then Node.HeaderSize := SizeOf(Header)
  else Node.HeaderSize := Header.Union.HdrSize;
  Node.Size := Header.Size;
  Node.PropCount := Header.PropCount;
  Stream.Seek(Node.HeaderSize - SizeOf(Header), soFromCurrent);
  Node.Previous := CurObject;
  CurObject := Node;
end;

function TDzBinaryClassReader.ReadFloat(const Name: TNameString;
  out Value: Extended): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtFloat], Name);
  Result := Kind <> dtUnknown;
  if Result then Stream.Read(Value, SizeOf(Value));
end;

procedure TDzBinaryClassReader.ReadListHeader;
var
  Node: PNestedObjectNode;
  Header: TListHeader;
begin
  New(Node);
  Node.Previous := CurObject;
  CurObject := Node;
  Node.Offset := Stream.Position;
  Stream.Read(Header, SizeOf(Header));
  Node.Kind := dtList;
  Node.ListKind := TDataType(Header.ItemType);
  Node.Size := Header.Size;
  Node.ItemCount := Header.ItemCount;
end;

function TDzBinaryClassReader.ReadQWord(const Name: TNameString;
  out Value: Int64): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtByte, dtWord, dtInt32, dtInt64], Name);
  Result := Kind <> dtUnknown;
  if Result then
  case Kind of
    dtByte: Value := _ReadByte;
    dtWord: Value := _ReadWord;
    dtInt32: Value := _ReadInt32;
    else Stream.Read(Value, SizeOf(Value));
  end;
end;

function TDzBinaryClassReader.ReadStrLen(Level: Integer): Integer;
begin
  case Level of
    0: Result := _ReadByte;
    1: Result := _ReadWord;
    2: Result := Stream.Read(Result, SizeOf(Result));
  end;
end;

function TDzBinaryClassReader.ReadDWord(const Name: TNameString;
  out Value: Integer): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtByte, dtWord, dtInt32], Name);
  Result := Kind <> dtUnknown;
  if Result then
  case Kind of
    dtByte: Value := _ReadByte;
    dtWord: Value := _ReadWord;
    else Stream.Read(Value, SizeOf(Value));
  end;
end;

{$WARNINGS OFF}
function TDzBinaryClassReader.ReadName(out Name: TNameString): Integer;
var
  Flag: Byte;
  Len: Byte absolute Flag;
  StrTag: Cardinal;
  IsPtr: Boolean;
  Bookmark: Int64;
  Offset: Integer;
begin
  Stream.Read(Flag, SizeOf(Flag));
  if (Flag and $80) <> 0 then
  begin
    IsPtr := True;
    Stream.Seek(-1, soFromCurrent);
    Stream.Read(StrTag, SizeOf(StrTag));
    Bookmark := Stream.Position;
    StrTag := BigEndianToSys(StrTag);
    StrTag := StrTag and not STRING_FLAG_PTR;
    Stream.Position := Bookmark - StrTag;
    Stream.Read(Len, SizeOf(Len));
    Result := SizeOf(StrTag);
  end
  else begin
    IsPtr := False;
    Result := SizeOf(Len);
  end;

  case NameEncoding of
    teAnsi: Offset := ReadAnsiName(Name, Len);
    teUTF8: Offset := ReadUTF8Name(Name, Len);
    teUTF16: Offset := ReadUTF16Name(Name, Len);
    teUTF32: Result := 0;
    teUCS4: Result := 0;
    else Result := 0;
  end;

  if IsPtr then Stream.Position := Bookmark
  else Inc(Result, Offset);
end;
{$WARNINGS ON}

function TDzBinaryClassReader.ReadPointer(const Name: TNameString;
  Buf: Pointer; var Len: Integer): Boolean;
var
  Kind: TDataType;
  StoredLen: Integer;
  Bookmark: Int64;
begin
  Bookmark := Stream.Position;
  Kind := FindProperty([dtPointer], Name);
  Result := Kind <> dtUnknown;
  if not Result then Exit;
  Stream.Read(StoredLen, SizeOf(StoredLen));
  if Buf = nil then
  begin
    Len := StoredLen;
    Stream.Position := Bookmark;
    Exit;
  end;
  if Len > StoredLen then Len := StoredLen;
  Len := Stream.Read(Buf^, Len);
  Stream.Seek(StoredLen - Len, soFromCurrent);
  Result := True;
end;

procedure TDzBinaryClassReader.ReadPropList(props: TStrings);
begin
  //
end;

function TDzBinaryClassReader.ReadPropType: TDataType;
var
  Kind: TDataTypeRange;
begin
  Stream.Read(Kind, SizeOf(Kind));
  Result := TDataType(Kind);
end;

function TDzBinaryClassReader._ReadUnicodeStr(
  out Str: WideString; LenLevel: Integer): Integer;
var
  Len: Integer;
begin
  Len := ReadStrLen(LenLevel);
  SetLength(Str, Len);
  Stream.Read(Pointer(Str)^, Len * 2);
  Result := LEN_BYTES[LenLevel] + Len * 2;
end;

function TDzBinaryClassReader._ReadWideStr(out Str: WideString;
  LenLevel: Integer): Integer;
var
  Len: Integer;
begin
  Len := ReadStrLen(LenLevel);
  SetLength(Str, Len);
  Stream.Read(Pointer(Str)^, Len * 2);
  Result := LEN_BYTES[LenLevel] + Len * 2;
end;

function TDzBinaryClassReader._ReadWord: Word;
begin
  Stream.Read(Result, SizeOf(Result));
end;

{$HINTS OFF}
function TDzBinaryClassReader.ReadUTF16Name(
  out Name: TNameString; Len: Integer): Integer;
var
  astr: array [0..255] of AnsiChar;
  wstr: array[0..255] of WideChar;
  alen: Integer;
begin
  Result := Len shl 1;
  if SizeOf(Name[1]) = 1 then
  begin
    Stream.Read(wstr, Result);
    SetLength(Name, Result);
    SetLength(Name, uDZStr.wctomb(wstr, Len, @Name[1], Result));
  end
  else begin
    SetLength(Name, Len);
    Stream.Read(Name[1], Result);
  end;
end;
{$HINTS ON}

function TDzBinaryClassReader.ReadUStrListItem(Index: Integer;
  out Value: WideString; out More: Boolean): Boolean;
var
  Kind: TDataType;
  astr: AnsiString;
begin
  Kind := ReadPropType;
  if Kind in [dtShortWideStr, dtSmallWideStr, dtLongWideStr] then
  begin
    _ReadUnicodeStr(Value, Ord(Kind) - Ord(dtShortWideStr));
    with CurObject^ do More := (Offset + Size) > Stream.Position;
    Result := True;
  end
  else if Kind in [dtShortAnsiStr, dtSmallAnsiStr, dtLongAnsiStr] then
  begin
    _ReadAnsiStr(astr, Ord(Kind) - Ord(dtShortAnsiStr));
    Value := WideString(astr);
    with CurObject^ do More := (Offset + Size) > Stream.Position;
    Result := True;
  end
  else begin
    More := False;
    Result := False;
  end;
end;

function TDzBinaryClassReader.ReadUnicodeStr(const Name: TNameString;
  out Value: WideString): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtShortWideStr, dtSmallWideStr, dtLongWideStr], Name);
  Result := Kind <> dtUnknown;
  if Result then _ReadUnicodeStr(Value, Ord(Kind) - Ord(dtShortWideStr));
end;

function TDzBinaryClassReader.ReadUTF8Name(
  out Name: TNameString; Len: Integer): Integer;
var
  ustr: array [0..255] of AnsiChar;
  wstr: array[0..255] of WideChar;
  wlen: Integer;
begin
  if SizeOf(Name[1]) = 1 then
  begin
    Stream.Read(ustr, Len);
    wlen := uDZStr.Utf8ToUnicode(ustr, Len, wstr, Length(wstr));
    SetLength(Name, wlen shl 1);
    SetLength(Name, uDZStr.wctomb(wstr, wlen, @Name[1], wlen shl 1));
  end
  else begin
    Stream.Read(ustr, Len);
    SetLength(Name, Len);
    SetLength(Name, uDZStr.Utf8ToUnicode(ustr, Len,
      PWideChar(Pointer(@Name[1])), Len));
  end;
  Result := Len;
end;

function TDzBinaryClassReader.ReadWideChar(const Name: TNameString;
  out Value: WideChar): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtByte, dtWord], Name);
  case Kind of
    dtUnknown: Result := False;
    dtByte:
      begin
        Value := WideChar(_ReadByte);
        Result := True;
      end;
    else
      begin
        Stream.Read(Value, SizeOf(Value));
        Result := True;
      end;
  end;
end;

function TDzBinaryClassReader.ReadWStrListItem(Index: Integer;
  out Value: WideString; out More: Boolean): Boolean;
var
  Kind: TDataType;
  astr: AnsiString;
begin
  Kind := ReadPropType;
  if Kind in [dtShortWideStr, dtSmallWideStr, dtLongWideStr] then
  begin
    _ReadWideStr(Value, Ord(Kind) - Ord(dtShortWideStr));
    with CurObject^ do More := (Offset + Size) > Stream.Position;
    Result := True;
  end
  else if Kind in [dtShortAnsiStr, dtSmallAnsiStr, dtLongAnsiStr] then
  begin
    _ReadAnsiStr(astr, Ord(Kind) - Ord(dtShortAnsiStr));
    Value := WideString(astr);
    with CurObject^ do More := (Offset + Size) > Stream.Position;
    Result := True;
  end
  else begin
    More := False;
    Result := False;
  end;
end;

function TDzBinaryClassReader.ReadWideStr(const Name: TNameString;
  out Value: WideString): Boolean;
var
  Kind: TDataType;
begin
  Kind := FindProperty([dtShortWideStr, dtSmallWideStr, dtLongWideStr], Name);
  Result := Kind <> dtUnknown;
  if Result then _ReadWideStr(Value, Ord(Kind) - Ord(dtShortWideStr));
end;

procedure TDzBinaryClassReader.SkipPropName;
var
  Flag: Byte;
begin
  if NameStore = nsHash then
  begin
    Stream.Seek(SizeOf(Word), soFromCurrent);
    Exit;
  end;
  Stream.Read(Flag, SizeOf(Flag));
  if (Flag and $80) <> 0 then
  begin
    Stream.Seek(SizeOf(Integer) - SizeOf(Flag) , soFromCurrent);
    Exit;
  end;

  case NameEncoding of
    teAnsi, teUTF8: Stream.Seek(Flag, soFromCurrent);
    teUTF16: Stream.Seek(Flag * 2, soFromCurrent);
    teUTF32, teUCS4: Stream.Seek(Flag * 4, soFromCurrent);
  end;
end;

procedure TDzBinaryClassReader.SkipProp(Kind: TDataType; SkipName: Boolean);
var
  ObjHdr: TObjectHeader;
  ListHdr: TListHeader;
  Len: Integer;
begin
  case Kind of
    dtList:
      begin
        Stream.Read(Pointer(Cardinal(@ListHdr) + SizeOf(TDataTypeRange))^,
          SizeOf(ListHdr) - SizeOf(TDataTypeRange));
        Stream.Seek(ListHdr.Size - SizeOf(ListHdr), soFromCurrent);
      end;
    dtClass:
      begin
        Stream.Read(Pointer(Cardinal(@ObjHdr) + SizeOf(TDataTypeRange))^,  
          SizeOf(ObjHdr) - SizeOf(TDataTypeRange));
        Stream.Seek(ObjHdr.Size - SizeOf(ObjHdr), soFromCurrent);
      end;
    dtByte:
      begin
        if SkipName then SkipPropName;
        Stream.Seek(1, soFromCurrent);
      end;
    dtWord:
      begin
        if SkipName then SkipPropName;
        Stream.Seek(2, soFromCurrent);
      end;
    dtInt32:
      begin
        if SkipName then SkipPropName;
        Stream.Seek(SizeOf(Integer), soFromCurrent);
      end;
    dtFloat:
      begin
        if SkipName then SkipPropName;
        Stream.Seek(SizeOf(Extended), soFromCurrent);
      end;
    dtShortUTF8Str, dtSmallUTF8Str, dtLongUTF8Str:
      begin
        if SkipName then SkipPropName;
        Len := ReadStrLen(Ord(Kind) - Ord(dtShortUTF8Str));
        Stream.Seek(Len, soFromCurrent);
      end;
    dtShortAnsiStr..dtLongAnsiStr:
      begin
        if SkipName then SkipPropName;
        Len := ReadStrLen(Ord(Kind) - Ord(dtShortAnsiStr));
        Stream.Seek(Len, soFromCurrent);
      end;
    dtShortWideStr..dtLongWideStr:
      begin
        if SkipName then SkipPropName;
        Len := ReadStrLen(Ord(Kind) - Ord(dtShortWideStr));
        Stream.Seek(Len shl 1, soFromCurrent);
      end;
    dtArray: ;
    dtInt64:
      begin
        if SkipName then SkipPropName;
        Stream.Seek(SizeOf(Int64), soFromCurrent);
      end;
    dtPointer:
      begin
        if SkipName then SkipPropName;
        Stream.Read(Len, SizeOf(Len));
        Stream.Seek(Len, soFromCurrent);
      end;
  end;
end;

function TDzBinaryClassReader.FindPropUntil(Kinds: TDataTypes;
  const Name: TNameString; EndPos: Int64): TDataType;
var
  Header: TObjectHeader;
  Bookmark: Int64;
  TypeValid: Boolean;
begin
  while Stream.Position < EndPos do
  begin
    Result := ReadPropType;
    TypeValid := Result in Kinds;

    if not TypeValid then
    begin
      SkipProp(Result);
      Continue;
    end;

    if Result = dtList then
    begin
      Stream.Seek(-SizeOf(TDataTypeRange), soFromCurrent);
      ReadListHeader;
      Exit;
    end;

    if Result = dtClass then
    begin
      Stream.Seek(-SizeOf(TDataTypeRange), soFromCurrent);
      Bookmark := Stream.Position;
      Stream.Read(Header, SizeOf(Header));
      if SamePropName(Name) then
      begin
        Stream.Position := Bookmark;
        ReadObjectHeader;
        Exit;
      end;
      Stream.Position := Bookmark + Header.Size;
      Continue;
    end;

    if SamePropName(Name) then Exit;

    SkipProp(Result, False);
  end;
  Result := dtUnknown;
end;

function TDzBinaryClassReader._ReadAnsiStr(
  out Str: AnsiString; LenLevel: Integer): Integer;
var
  Len: Integer;
begin
  Len := ReadStrLen(LenLevel);
  SetLength(Str, Len);
  Stream.Read(Pointer(Str)^, Len);
  Result := LEN_BYTES[LenLevel] + Len;
end;

function TDzBinaryClassReader._ReadByte: Byte;
begin
  Stream.Read(Result, SizeOf(Result));
end;

function TDzBinaryClassReader._ReadInt32: Integer;
begin
  Stream.Read(Result, SizeOf(Result));
end;

function TDzBinaryClassReader._ReadQWord: Integer;
begin
  Stream.Read(Result, SizeOf(Result));
end;

end.
